home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Emitcode.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  10.5 KB  |  322 lines  |  [TEXT/R*ch]
  1. open
  2.   Obj Fnlib Config Mixture Const Instruct Prim
  3.   Opcodes Prim_opc Buffcode Labels Reloc
  4. ;
  5.  
  6. (* 1996.07.13 -- e *)
  7.  
  8. prim_val lshift_    : int -> int -> int = 2 "shift_left";
  9. prim_val rshiftsig_ : int -> int -> int = 2 "shift_right_signed";
  10. prim_val rshiftuns_ : int -> int -> int = 2 "shift_right_unsigned";
  11.  
  12.  
  13. (* Generation of bytecode for .uo files *)
  14.  
  15. fun checkAccessIndex n =
  16.   if n <= maxint_byte then () else
  17.     (msgIBlock 0;
  18.      errPrompt "Too many local variables, unable to compile into bytecode";
  19.      msgEOL();
  20.      msgEBlock();
  21.      raise Toplevel)
  22. ;
  23.  
  24. fun out_bool_test tst =
  25.   fn PTeq    => out tst
  26.    | PTnoteq => out (tst + 1)
  27.    | PTlt    => out (tst + 2)
  28.    | PTgt    => out (tst + 3)
  29.    | PTle    => out (tst + 4)
  30.    | PTge    => out (tst + 5)
  31.    | _       => fatalError "out_bool_test"
  32. ;
  33.  
  34. fun out_int_const i =
  35.   if i >= minint_short andalso i <= maxint_short then
  36.     if i >= 0 andalso i <= 3
  37.     then
  38.       out (CONST0 + i)
  39.     else
  40.       let val ii1 = i+i+1 in
  41.         if ii1 >= minint_byte andalso ii1 <= maxint_byte then
  42.           (out CONSTBYTE; out (ii1))
  43.         else if ii1 >= minint_short andalso ii1 <= maxint_short then
  44.           (out CONSTSHORT; out_short (ii1))
  45.         else
  46.           (out CONSTINT; out_long i)
  47.       end
  48.   else
  49.     (out CONSTINT; out_long i)
  50. ;
  51. fun out_word_const w =
  52.     let prim_val w2i : word -> int = 1 "identity"
  53.     in out_int_const (w2i w) end;
  54.  
  55. fun out_push_int_const i =
  56.   if i >= minint_short andalso i <= maxint_short then
  57.     if i >= 0 andalso i <= 3
  58.     then
  59.       out (PUSHCONST0 + i)
  60.     else
  61.       let val ii1 = i+i+1 in
  62.         if ii1 >= minint_byte andalso ii1 <= maxint_byte then
  63.           (out PUSH; out CONSTBYTE; out (ii1))
  64.         else if ii1 >= minint_short andalso ii1 <= maxint_short then
  65.           (out PUSH; out CONSTSHORT; out_short (ii1))
  66.         else
  67.           (out PUSHCONSTINT; out_long i)
  68.       end
  69.   else
  70.     (out PUSHCONSTINT; out_long i)
  71. ;
  72. fun out_push_word_const w =
  73.     let prim_val w2i : word -> int = 1 "identity"
  74.     in out_push_int_const (w2i w) end;
  75.  
  76. fun out_tag (CONtag(t,_)) = out t
  77.   | out_tag (EXNtag(name, stamp)) =
  78.       slot_for_tag name stamp
  79. ;
  80.  
  81. fun out_header (n, tag) =
  82. (
  83.   out_tag tag;
  84.   out (lshift_ n 2);
  85.   out (rshiftuns_ n 6);
  86.   out (rshiftuns_ n 14)
  87. );
  88.  
  89. fun emit_zam zam =
  90.   case zam of
  91.       Kquote(ATOMsc(INTscon i)) => out_int_const i
  92.     | Kquote(ATOMsc(WORDscon w)) => out_word_const w
  93.     | Kquote(ATOMsc(CHARscon c)) => out_int_const (Char.ord c)
  94.     | Kquote(BLOCKsc(tag, [])) =>
  95.         (case tag of
  96.              CONtag(t,_) =>
  97.                if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
  98.            | EXNtag(name, stamp) =>
  99.                (out ATOM; slot_for_tag name stamp)
  100.         )
  101.     | Kquote sc =>       (out GETGLOBAL; slot_for_literal sc)
  102.     | Kget_global uid => (out GETGLOBAL; slot_for_get_global uid)
  103.     | Kset_global uid => (out SETGLOBAL; slot_for_set_global uid)
  104.     | Kgetfield n =>
  105.         (if n < 4 then out (GETFIELD0 + n)
  106.          else (out GETFIELD; out_short n)) (* check n? *)
  107.     | Ksetfield n =>
  108.         (if n < 4 then out (SETFIELD0 + n)
  109.          else (out SETFIELD; out_short n)) (* check n? *)
  110.     | Kaccess n =>
  111.         (checkAccessIndex n;
  112.          if n < 8 then out(ACC0 + n) else (out ACCESS; out n))
  113.     | Kenvacc m =>
  114.         let val n = m + 1
  115.         in
  116.           checkAccessIndex n;
  117.           if n < 8 then out(ENV1 + m) else (out ENVACC; out n)
  118.         end
  119.     | Kassign n =>
  120.         (checkAccessIndex n; out ASSIGN; out n)
  121.     | Kapply n =>
  122.         (checkAccessIndex n;
  123.          if n < 5 then out(APPLY1 + n - 1) else (out APPLY; out n))
  124.     | Kappterm (n,z) =>
  125.         (checkAccessIndex n;
  126.          if n < 5 then out(APPTERM1 + n - 1) else (out APPTERM; out n);
  127.          checkAccessIndex z;
  128.          out z)
  129.     | Kpop n =>    (checkAccessIndex n; out POP;    out n)
  130.     | Kgrab n =>   (checkAccessIndex n; out GRAB;   out n)
  131.     | Kreturn n => 
  132.     (checkAccessIndex n; 
  133.      if n < 3 then out(RETURN1 + n - 1) else (out RETURN; out n))
  134.     | Kmakeblock(tag,n) =>
  135.         (if n <= 0 then
  136.            fatalError "emit_zam : Kmakeblock"
  137.          else if n < 5 then
  138.            (out (MAKEBLOCK1 + n - 1);
  139.             out_tag tag)
  140.          else
  141.           (out MAKEBLOCK;
  142.            out_header(n, tag)))
  143.     | Klabel lbl =>
  144.         if lbl = Nolabel then fatalError "emit_zam: undefined label"
  145.         else (define_label lbl)
  146.     | Kclosure (lbl,sz) => (out CLOSURE; out sz; out_label lbl)
  147.     | Kclosurerec (lbl,sz) => (out CLOSREC; out (sz - 1); out_label lbl)
  148.     | Kpushtrap lbl => (out PUSHTRAP; out_label lbl)
  149.     | Kpush_retaddr lbl => (out PUSH_RETADDR; out_label lbl)
  150.     | Kbranch lbl => (out BRANCH; out_label lbl)
  151.     | Kbranchif lbl => (out BRANCHIF; out_label lbl)
  152.     | Kbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
  153.     | Kstrictbranchif lbl => (out BRANCHIF; out_label lbl)
  154.     | Kstrictbranchifnot lbl => (out BRANCHIFNOT; out_label lbl)
  155.     | Kswitch lblvect =>
  156.         let val len = Array.length lblvect
  157.             val ()  = out SWITCH;
  158.             val ()  = out len;
  159.             val orig = !out_position
  160.         in
  161.           for (fn i => out_label_with_orig orig (Array.sub(lblvect, i)))
  162.               0 (len-1)
  163.         end
  164.     | Ktest(tst,lbl) =>
  165.         (case tst of
  166.              Peq_test =>
  167.                (out BRANCHIFEQ; out_label lbl)
  168.            | Pnoteq_test =>
  169.                (out BRANCHIFNEQ; out_label lbl)
  170.            | Pint_test(PTnoteqimm i) =>
  171.                (out PUSH; out_push_int_const i;
  172.                 out EQ; out POPBRANCHIFNOT; out_label lbl)
  173.            | Pint_test x =>
  174.                (out_bool_test BRANCHIFEQ x; out_label lbl)
  175.            | Pfloat_test(PTnoteqimm f) =>
  176.                (out PUSH; out PUSH_GETGLOBAL;
  177.                 slot_for_literal (ATOMsc(REALscon f));
  178.                 out EQFLOAT; out POPBRANCHIFNOT; out_label lbl)
  179.            | Pfloat_test x =>
  180.                (out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl)
  181.            | Pstring_test(PTnoteqimm s) =>
  182.                (out PUSH; out PUSH_GETGLOBAL;
  183.                 slot_for_literal (ATOMsc(STRINGscon s));
  184.                 out EQSTRING; out POPBRANCHIFNOT; out_label lbl)
  185.            | Pstring_test x =>
  186.                (out_bool_test EQSTRING x; out BRANCHIF; out_label lbl)
  187.            | Pword_test(PTnoteqimm w) =>
  188.                (out PUSH; out_push_word_const w;
  189.                 out EQUNSIGN; out POPBRANCHIFNOT; out_label lbl)
  190.            | Pword_test x =>
  191.                (out_bool_test EQUNSIGN x; out BRANCHIF; out_label lbl)
  192.            | Pnoteqtag_test tag =>
  193.                (out BRANCHIFNEQTAG; out_tag tag; out_label lbl)
  194.          )
  195.     | Kbranchinterval(low, high, lbl_low, lbl_high) =>
  196.         (out_push_int_const low;
  197.          if low <> high then out_push_int_const high else out PUSH;
  198.          out BRANCHINTERVAL;
  199.          out_label lbl_low;
  200.          out_label lbl_high
  201.         )
  202.     | Kprim p =>
  203.         (case p of
  204.             Pdummy n =>
  205.               (checkAccessIndex n; out DUMMY; out n)
  206.           | Ptest tst =>
  207.               (case tst of
  208.                   Peq_test => out EQ
  209.                 | Pnoteq_test => out NEQ
  210.                 | Pint_test tst => out_bool_test EQ tst
  211.                 | Pfloat_test tst => out_bool_test EQFLOAT tst
  212.                 | Pstring_test tst => out_bool_test EQSTRING tst
  213.                 | Pword_test tst => out_bool_test EQUNSIGN tst
  214.                 | _ => fatalError "emit_zam : Kprim, Ptest")
  215.           | Patom t =>
  216.               if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
  217.           | Pccall(name, arity) =>
  218.               (if arity <= 5 then
  219.                  out (C_CALL1 + arity - 1)
  220.                else
  221.                  (out C_CALLN; out arity);
  222.                slot_for_c_prim name)
  223.           | Pfloatprim p =>
  224.               out(opcode_for_float_primitive p)
  225.           | Pidentity =>
  226.               ()
  227.           | p =>
  228.               out(opcode_for_primitive p)
  229.          )
  230.     | Kpush => out PUSH
  231.     | Kraise => out RAISE
  232.     | Krestart => out RESTART
  233.     | Kpoptrap => out POPTRAP
  234.     | Kcheck_signals => out CHECK_SIGNALS
  235. ;
  236.  
  237. fun emit zams =
  238.   case zams of
  239.       [] => ()
  240.     | Kpush :: Kquote(ATOMsc(INTscon i)) :: C =>
  241.         (out_push_int_const i; emit C)
  242.     | Kpush :: Kquote(ATOMsc(WORDscon w)) :: C =>
  243.         (out_push_word_const w; emit C)
  244.     | Kpush :: Kquote(ATOMsc(CHARscon c)) :: C =>
  245.         (out_push_int_const (Char.ord c); emit C)
  246.     | Kpush :: Kquote(BLOCKsc(tag, [])) :: C =>
  247.         (case tag of
  248.              CONtag(t,_) =>
  249.                if t = 0 then out PUSHATOM0 else (out PUSHATOM; out t)
  250.            | EXNtag(name, stamp) =>
  251.                (out PUSHATOM; slot_for_tag name stamp);
  252.          emit C
  253.         )
  254.     | Kpush :: Kquote sc :: C => (out PUSH_GETGLOBAL; slot_for_literal sc; emit C)
  255.     | Kpush :: Kaccess n :: C =>
  256.         (checkAccessIndex n;
  257.          if n < 8 then out(PUSHACC0 + n) else (out PUSHACC; out n);
  258.          emit C)
  259.     | Kpush :: Kenvacc 0 :: Kapply n :: C =>
  260.         (checkAccessIndex n;
  261.          if n < 5 then 
  262.          out(PUSH_ENV1_APPLY1 + n - 1)
  263.      else 
  264.          (out PUSHENV1;
  265.           out APPLY; out n);
  266.          emit C)
  267.     | Kpush :: Kenvacc 0 :: Kappterm (n,z) :: C =>
  268.         (checkAccessIndex n;
  269.          if n < 5 then 
  270.          (out(PUSH_ENV1_APPTERM1 + n - 1);
  271.           checkAccessIndex z; out z)
  272.      else 
  273.          (out PUSHENV1;
  274.           out APPTERM; out n;
  275.           checkAccessIndex z; out z);
  276.          emit C)
  277.     | Kpush :: Kenvacc m :: C =>
  278.         let val n = m + 1
  279.         in
  280.           checkAccessIndex n;
  281.           if n < 8 then out(PUSHENV1 + m) else (out PUSHENVACC; out n);
  282.           emit C
  283.         end
  284.     | Kpush :: Kget_global uid :: Kapply n :: C =>
  285.         (checkAccessIndex n;
  286.          if n < 5 then 
  287.          (out(PUSH_GETGLOBAL_APPLY1 + n - 1);
  288.           slot_for_get_global uid)
  289.      else 
  290.          (out PUSH_GETGLOBAL;
  291.           slot_for_get_global uid;
  292.           out APPLY; out n);
  293.          emit C)
  294.     | Kpush :: Kget_global uid :: Kappterm (n,z) :: C =>
  295.         (checkAccessIndex n; 
  296.          if n < 5 then 
  297.          (out(PUSH_GETGLOBAL_APPTERM1 + n - 1);
  298.           checkAccessIndex z; out z;
  299.           slot_for_get_global uid)
  300.      else 
  301.          (out PUSH_GETGLOBAL;
  302.           slot_for_get_global uid;
  303.           out APPTERM; out n;
  304.           checkAccessIndex z;
  305.           out z);
  306.          emit C)
  307.     | Kpush :: Kget_global uid :: C =>
  308.         (out PUSH_GETGLOBAL;
  309.          slot_for_get_global uid;
  310.          emit C)
  311.     | Kgetfield 0 :: Kgetfield 0 :: C => 
  312.     (out GETFIELD0_0; emit C)
  313.     | Kgetfield 0 :: Kgetfield 1 :: C => 
  314.     (out GETFIELD0_1; emit C)
  315.     | Kgetfield 1 :: Kgetfield 0 :: C => 
  316.     (out GETFIELD1_0; emit C)
  317.     | Kgetfield 1 :: Kgetfield 1 :: C => 
  318.     (out GETFIELD1_1; emit C)
  319.     | zam :: C =>
  320.        (emit_zam zam; emit C)
  321. ;
  322.